home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / br-tree.el < prev    next >
Encoding:
Text File  |  1995-07-14  |  9.9 KB  |  304 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         br-tree.el
  4. ;; SUMMARY:      Interface between textual and graphical OO-Browsers.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     mouse, oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:    12-Oct-90
  12. ;; LAST-MOD:      5-Jun-95 at 12:00:10 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1990-1995  Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18. ;;
  19. ;; DESCRIPTION:  
  20. ;;
  21. ;;   Requires the X Window system Version 11 or NEXTSTEP.
  22. ;;
  23. ;; DESCRIP-END.
  24.  
  25. ;;; ************************************************************************
  26. ;;; Other required Elisp libraries
  27. ;;; ************************************************************************
  28.  
  29. (require 'br-lib)
  30.  
  31. ;;; ************************************************************************
  32. ;;; Public variables
  33. ;;; ************************************************************************
  34.  
  35. (defvar *br-tree-prog-name*
  36.   (if (or (eq window-system 'x) (null window-system))
  37.       "xoobr"
  38.     "./TreeView.app/TreeView")
  39.   "Program to run for hierarchical display of classes.")
  40.  
  41. ;;; ************************************************************************
  42. ;;; Public functions
  43. ;;; ************************************************************************
  44.  
  45. (defun br-tree (&optional arg)
  46.   "Start the appropriate tree application with descendency tree of current class.
  47. With optional prefix ARG, a descendency tree for each class in current buffer."
  48.   (interactive "P")
  49.   (let* ((classes (if arg
  50.             (br-this-level-classes)
  51.           (list (br-find-class-name))))
  52.      (ch (delq nil (mapcar (function (lambda (c) (br-get-children c)))
  53.                   classes))))
  54.     (if (or ch br-show-features)
  55.     (br-tree-load classes)
  56.       (beep)
  57.       (message "No descendants to display."))))
  58.  
  59. (defun br-tree-graph ()
  60.   "Start the appropriate tree application with the tree from current listing buffer."
  61.   (interactive)
  62.   (let* ((tree) (indent) (entry) (min-indent 8000) (min-count 0)
  63.      (feature-match (format "^%s " br-feature-type-regexp)))
  64.     (save-excursion
  65.       (goto-char (point-max))
  66.       (while (and (= (forward-line -1) 0)
  67.           (looking-at "\\([ \t]*\\)\\(.+\\)"))
  68.     (setq indent (buffer-substring (match-beginning 1) (match-end 1))
  69.           entry (length indent)
  70.           min-indent (cond ((= entry min-indent)
  71.                 (setq min-count (1+ min-count))
  72.                 entry)
  73.                    ((< entry min-indent)
  74.                 (setq min-count 1)
  75.                 entry)
  76.                    (min-indent))
  77.           entry (buffer-substring (match-beginning 2) (match-end 2))
  78.           entry (if (string-match feature-match entry)
  79.             (concat (char-to-string (aref entry 0))
  80.                 (substring entry 2)
  81.                 "^^" (br-feature-get-signature))
  82.               entry)
  83.           tree (cons (concat indent entry "\n") tree))))
  84.     (or (= min-count 1)
  85.     (setq tree (cons (concat *br-tree-root-name* "\n")
  86.              (mapcar (function
  87.                   (lambda (node) (concat "  " node))) tree))))
  88.     (br-tree-load tree t)))
  89.  
  90. (defun br-tree-do-cmd (lang env cmd node)
  91.   ;; Load necessary Environment
  92.   (if (not (equal env br-env-file))
  93.       (let ((br (intern-soft
  94.           (concat lang "browse"))))
  95.     (if (br-in-browser) (funcall br env) (funcall br env t))))
  96.   ;; Do command
  97.   (cond ((and (not (eq (symbol-function 'br-feature-tree-command-p)
  98.                'br-undefined-function))
  99.           (br-feature-tree-command-p node)))
  100.     ((string-equal cmd "br-view")
  101.      (br-view nil nil node))
  102.     ((string-equal cmd "br-edit")
  103.      (br-view nil t node))
  104.     (t (beep)
  105.        (message
  106.         (format "(OO-Browser):  Illegal command: %s" cmd)))))
  107.  
  108. (defun br-tree-features-toggle ()
  109.   "Toggle between showing and hiding features when 'br-tree' is invoked to display descendants graphically."
  110.   (interactive)
  111.   (setq br-show-features (not br-show-features))
  112.   (message "New graphical OO-Browsers will %sshow features."
  113.        (if br-show-features "" "not ")))
  114.  
  115. (defun br-tree-kill ()
  116.   "Kill all current 'Tree' sub-processes."
  117.   (interactive)
  118.   (if (br-kill-process-group br-tree-name br-tree-num
  119.                  "Tree displays")
  120.       (setq br-tree-num 0)))
  121.  
  122. (defun br-tree-load (classes-or-tree &optional tree-p)
  123.   "Start the appropriate tree application using trees from CLASSES-OR-TREE.
  124. Optional TREE-P non-nil means CLASSES-OR-TREE is a tree ready for display."
  125.   (interactive (list "sClass to show descendency graph of: "))
  126.   (if (and br-env-file (not br-env-spec))
  127.       (let ((obuf (current-buffer))
  128.         (tree-file (concat "/tmp/br-" (user-real-login-name)
  129.                    (int-to-string
  130.                 (setq br-tree-num (1+ br-tree-num)))
  131.                    ".tree")))
  132.     (if classes-or-tree
  133.         (progn (find-file tree-file)
  134.            (widen)
  135.            (setq buffer-read-only nil)
  136.            (erase-buffer)
  137.            ;; Start file with Envir file name
  138.            (insert "^^" br-lang-prefix "^^" br-env-file "\n")
  139.            (if tree-p
  140.                (mapcar 'insert classes-or-tree)
  141.              (br-tree-build classes-or-tree))
  142.            (untabify 1 (point-max))
  143.            (save-buffer)
  144.            (kill-buffer (current-buffer))
  145.            (switch-to-buffer obuf)
  146.            (if (eq window-system 'x)
  147.                (br-tree-x-load-tree-file tree-file)
  148.              (br-tree-nx-load-tree-file tree-file)))))))
  149.  
  150. (defun br-tree-nx-load-tree-file (tree-file)
  151.   "Load a pre-written TREE-FILE and display it in an X OO-Browser."
  152.   (setq delete-exited-processes t)
  153.   (let ((proc (get-process br-tree-name)))
  154.     (if (and proc (eq (process-status proc) 'run))  ;; existing tree browser
  155.     ;; Send it an open file command.
  156.     (call-process "open" nil 0 nil "-a"
  157.               (file-name-nondirectory *br-tree-prog-name*)
  158.               tree-file)
  159.       (let ((default-directory (file-name-as-directory
  160.                  (expand-file-name "tree-nx" br-directory))))
  161.     (setq proc (start-process
  162.              br-tree-name nil *br-tree-prog-name*
  163.              tree-file))
  164.     (if proc
  165.         (progn (set-process-filter proc 'br-tree-filter)
  166.            (process-kill-without-query proc)
  167.            ))))))
  168.  
  169. (defun br-tree-x-load-tree-file (tree-file)
  170.   "Load a pre-written TREE-FILE and display it in an X OO-Browser."
  171.   (setq delete-exited-processes t)
  172.   (let ((proc))
  173.     (setq proc (start-process 
  174.         (concat br-tree-name (int-to-string br-tree-num))
  175.         nil
  176.         *br-tree-prog-name*
  177.         tree-file))
  178.     (if proc
  179.     (progn (set-process-filter proc 'br-tree-filter)
  180.            (process-kill-without-query proc)))))
  181.  
  182. ;;; ************************************************************************
  183. ;;; Private functions
  184. ;;; ************************************************************************
  185.  
  186. (defconst *br-tree-root-name* "NO-ROOT" 
  187.   "Name to give root tree node when graph with no root is used as input.")
  188.  
  189. (defun br-tree-build (class-list &optional indent offset)
  190.   "Insert descendant trees starting with classes from CLASS-LIST.
  191. Indent each class in CLASS-LIST by optional INDENT spaces (default is 0 in
  192. order to ensure proper initialization).  Offset each child level by optional
  193. OFFSET spaces from its parent (which must be greater than zero, default 2)."
  194.   (or indent (setq indent 0))
  195.   (or offset (setq offset 2))
  196.   (let ((prev-expansion-str " ...")
  197.     ch expand-subtree)
  198.     (if (= indent 0)
  199.     (progn (setq br-tmp-class-set nil)
  200.            (if (= (length class-list) 1)
  201.            nil
  202.          (insert *br-tree-root-name* "\n")
  203.          (setq indent offset))))
  204.     (if class-list
  205.     (progn 
  206.       (indent-to indent)
  207.       (mapcar (function (lambda (c)
  208.              (setq expand-subtree (br-set-cons br-tmp-class-set c)
  209.                ch (if expand-subtree (br-get-children c)))
  210.              (indent-to indent)
  211.              (insert c)
  212.              (and (not expand-subtree)
  213.               (br-has-children-p c)
  214.               (insert prev-expansion-str))
  215.              (insert "\n")
  216.              (if (and br-show-features
  217.                   (br-tree-build-features
  218.                    c expand-subtree (+ indent offset) offset))
  219.              nil
  220.                (if ch
  221.                (br-tree-build ch (+ indent offset) offset)))))
  222.           class-list))))
  223.   (if (= indent 0) (setq br-tmp-class-set nil)))
  224.  
  225. (defun br-tree-build-features (c expand-subtree indent offset)
  226.   "Each language under which this function is called must define its own
  227. version of 'br-list-features' and 'br-feature-signature-to-name'."
  228.   (let ((features) (ch))
  229.     (and expand-subtree
  230.      (setq features
  231.          (mapcar
  232.           (function
  233.            (lambda (feature-tag)
  234.              (concat (br-feature-signature-to-name feature-tag nil t)
  235.                  "^^" feature-tag)))
  236.           (br-list-features c)))
  237.      (progn
  238.        (mapcar
  239.          (function
  240.            (lambda (feature)
  241.          (indent-to indent)
  242.          (insert feature "\n")))
  243.          features)
  244.        (if (setq ch (if expand-subtree (br-get-children c)))
  245.            (br-tree-build ch indent offset))
  246.        t))))
  247.  
  248. (defun br-tree-filter (process output-str)
  249.   (let ((br-lang-px)
  250.     (br-env-nm)
  251.     (br-cmd-nm)
  252.     (br-node-nm))
  253.     (if (not (string-match "\n" output-str))
  254.     (setq br-cmd-str (concat br-cmd-str output-str))
  255.       (setq br-cmd-str (concat br-cmd-str
  256.                    (substring output-str 0 (match-beginning 0))))
  257.       (if (and (> (length br-cmd-str) 9)
  258.            (equal (substring br-cmd-str -4)
  259.               " ..."))
  260.       (setq br-cmd-str (substring br-cmd-str 0 -4)))
  261.       ;; Is a command only if starts with ^^
  262.       (if (and (> (length br-cmd-str) 1)
  263.            (equal (substring br-cmd-str 0 2) "^^")
  264.            (string-match
  265.         "^^^\\(.+\\)^^\\(.+\\)^^\\(.+\\)^^\\(.+\\)"
  266.         br-cmd-str))
  267.       (progn
  268.         (setq br-lang-px (substring br-cmd-str
  269.                     (+ (match-beginning 1) 2)
  270.                     (match-end 1))
  271.           br-env-nm (substring br-cmd-str
  272.                        (match-beginning 2)
  273.                        (match-end 2))
  274.           br-cmd-nm (substring br-cmd-str
  275.                        (match-beginning 3)
  276.                        (match-end 3))
  277.           br-node-nm (substring br-cmd-str
  278.                     (match-beginning 4)
  279.                     (match-end 4))
  280.           br-cmd-str nil)
  281.         (br-tree-do-cmd br-lang-px br-env-nm
  282.                 br-cmd-nm br-node-nm))
  283.     (beep)
  284.     (message "'%s': invalid command from graphical browser"
  285.          br-cmd-str)
  286.     (setq br-cmd-str nil)))))
  287.  
  288.  
  289. ;;; ************************************************************************
  290. ;;; Private functions
  291. ;;; ************************************************************************
  292.  
  293.  
  294. (defvar br-cmd-str nil
  295.   "Command string sent from graphical OO-Browser to the textual OO-Browser.")
  296.  
  297. (defvar br-show-features nil
  298.   "Non-nil means add features as child nodes in each graphical descendancy view.")
  299.  
  300. (defvar br-tree-num 0)
  301. (defvar br-tree-name "Tree")
  302.  
  303. (provide 'br-tree)
  304.